home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / gjr / cmplrtst.lha / lexpr.scm < prev    next >
Encoding:
Text File  |  1990-03-27  |  1.0 KB  |  45 lines
  1. ;;; -*- Scheme -*-
  2.  
  3. #|
  4. Description:
  5. This code tests variable arity procedures and the apply code in cmpproc.m4.
  6.  
  7. Usage:
  8. (tag 'pepe 1 2 3 4) -> ((pepe . 1) (pepe . 2) (pepe . 3) (pepe . 4))
  9. (fix 3.4) -> (3 .4)
  10. (fix 3 2) -> (1 1)
  11. (hack 1 2) -> (1 2 c d e ())
  12. (hack 1 2 3) -> (1 2 3 d e ())
  13. (hack 1 2 3 4) -> (1 2 3 4 e ())
  14. (hack 1 2 3 4 5) -> (1 2 3 4 5 ())
  15. (hack 1 2 3 4 5 6) -> (1 2 3 4 5 (6))
  16. (hack 1 2 3 4 5 6 7) -> (1 2 3 4 5 (6 7))
  17. and so on
  18. |#
  19.  
  20. (declare (usual-integrations))
  21.  
  22. (define (tag the-tag . elements)
  23.   (define (inner left)
  24.     (if (null? left)
  25.     '()
  26.     (cons (cons the-tag (car left))
  27.           (inner (cdr left)))))
  28.   (inner elements))
  29.  
  30. (define (fix a #!optional b)
  31.   (define (kernel x receiver)
  32.     (let ((y (floor x)))
  33.       (receiver y (- x y))))
  34.  
  35.   (if (unassigned? b)
  36.       (kernel a list)
  37.       (kernel (/ a b)
  38.           (lambda (int frac)
  39.         (list int (* b frac))))))
  40.  
  41. (define (hack a b #!optional c d e . f)
  42.   (if (unassigned? c) (set! c 'c))
  43.   (if (unassigned? d) (set! d 'd))
  44.   (if (unassigned? e) (set! e 'e))
  45.   (list a b c d e f))